Conjoint Analysis Team Project

Purpose and product

The following is a conjoint analysis for a breakfast product to be sold in Tokyo, mainly targeting office professionals.

Defining the attributes

The research will include six attributes. Conventional attributes:

• Price
• Form
• Purchase Location

Innovative attributes:

• Fun Packaging
• Cognitive Support
• Digital Integration

Loading the data and creating the attribute:

# load required libraries

library(conjoint)
library(dplyr)
library(purrr)
library(readxl)
library(usethis)
library(ggplot2)
library(knitr)
library(googlesheets4)
library(forcats)
library(tidyr)
library(gridExtra)
library(tidytext)
library(tidyr)
library(wordcloud)
library(reshape2)
library(syuzhet)
library(wordcloud)
library(topicmodels)
library(utf8)
library(readxl)
library(textdata)
library(lubridate)
library(plotly)
library(GGally)
library(factoextra)
library(cluster)

# source custom functions from sensei
source("SCRIPTS/conjoint_tool_new.R")
source("SCRIPTS/cltool_new.R")


# define the attributes
attribute <- list(
  Price = c("200", "400", "600"),
  Form = c("Bread and Pastries","Onigiri","Protein sticks"),
  PurchaseLocation = c("On Route to work","Within 150m", "More than 150m"),
  FunPackaging = c("None", "Attack on Titan", "Doan Ritsu"),
  CognitiveSupport = c("None","Caffeine or Alertness boost",
                       "Natural Mood Stabilizer"),
  DigitalIntegration = c("None", "Loyalty points", "Nutrition Advice")
)

kable(data.frame(attribute))

Price	Form	PurchaseLocation	FunPackaging	CognitiveSupport	DigitalIntegration
200	Bread and Pastries	On Route to work	None	None	None
400	Onigiri	Within 150m	Attack on Titan	Caffeine or Alertness boost	Loyalty points
600	Protein sticks	More than 150m	Doan Ritsu	Natural Mood Stabilizer	Nutrition Advice

Generating products for survey

To generate the combinations for the survey, we run:

# Step 2: Profile Construction
# Full factorial design
profiles <- expand.grid(attribute)

# Orthogonal design
design.o <- caFactorialDesign(data=profiles, type="fractional", cards=13)
# Assigning incremental id for clarity
design.o.p <- tibble::rowid_to_column(design.o, "ID")
# Assigning variable for part-worth calculation
brkfst_design <- design.o

# Displaying table
kable(design.o.p)

ID	Price	Form	PurchaseLocation	FunPackaging	CognitiveSupport	DigitalIntegration
1	600	Bread and Pastries	More than 150m	Attack on Titan	None	None
2	200	Protein sticks	On Route to work	Doan Ritsu	None	None
3	400	Onigiri	More than 150m	None	Caffeine or Alertness boost	None
4	600	Onigiri	On Route to work	Attack on Titan	Natural Mood Stabilizer	None
5	400	Bread and Pastries	Within 150m	Doan Ritsu	Natural Mood Stabilizer	None
6	400	Bread and Pastries	On Route to work	None	None	Loyalty points
7	600	Onigiri	More than 150m	Doan Ritsu	None	Loyalty points
8	200	Bread and Pastries	Within 150m	Attack on Titan	Caffeine or Alertness boost	Loyalty points
9	400	Protein sticks	More than 150m	Attack on Titan	Natural Mood Stabilizer	Loyalty points
10	400	Onigiri	Within 150m	Attack on Titan	None	Nutrition Advice
11	600	Protein sticks	Within 150m	None	Caffeine or Alertness boost	Nutrition Advice
12	400	Bread and Pastries	On Route to work	Doan Ritsu	Caffeine or Alertness boost	Nutrition Advice
13	200	Bread and Pastries	More than 150m	None	Natural Mood Stabilizer	Nutrition Advice

Data loading and sanitization

Proceeding with loading the data from the survey:

## reading the survey data
#Read google sheets data into R
brkfst <- read_excel("DATA/DDM_MCU_survey.xlsx", 
                            sheet = "Form Responses 1")

Before starting the analysis, we sanitize the data. Given that country input was free-hand with no pre-built validation, we take a look at the values collected:

# check country
brkfst %>% 
  group_by(country) %>% 
  summarize(n = n())

## # A tibble: 19 × 2
##    country         n
##    <chr>       <int>
##  1 Bangladesh      2
##  2 Bulgaria        1
##  3 China          11
##  4 India           4
##  5 Japan          10
##  6 Korea           1
##  7 Malaysia        2
##  8 Mongolia        1
##  9 Myanmar         1
## 10 PHILIPPINES     1
## 11 Philippines     2
## 12 Romania         2
## 13 Singapore       6
## 14 South Korea     1
## 15 TW              1
## 16 Taiwan          6
## 17 Thailand        3
## 18 Vietnam         4
## 19 singapore       2

We proceed to santize the country variable, and roll-up into a region variable:

# sanitize county
brkfst <- 
  brkfst %>% 
  mutate(country2 = case_when(country == "TW" ~ "Taiwan",
                              country == "singapore" ~ "Singapore",
                              country == "PHILIPPINES" ~ "Philippines",
                              TRUE ~ country))

# check country
brkfst %>% 
  group_by(country2) %>% 
  summarize(n = n())

## # A tibble: 16 × 2
##    country2        n
##    <chr>       <int>
##  1 Bangladesh      2
##  2 Bulgaria        1
##  3 China          11
##  4 India           4
##  5 Japan          10
##  6 Korea           1
##  7 Malaysia        2
##  8 Mongolia        1
##  9 Myanmar         1
## 10 Philippines     3
## 11 Romania         2
## 12 Singapore       8
## 13 South Korea     1
## 14 Taiwan          7
## 15 Thailand        3
## 16 Vietnam         4

# create region
brkfst <- brkfst %>%
  mutate(region = case_when(
    country2 %in% c("Taiwan", "China", "Japan", "Korea", 
                   "Mongolia", "South Korea") ~ "East Asia",
    country2 %in% c("Singapore", "Malaysia", "Thailand", "Vietnam",
                   "Myanmar", "Philippines" ) ~ "South-East Asia",
    country2 %in% c("India", "Bangladesh") ~ "Indian subcontinent",
    country2 %in% c("Bulgaria", "Romania", "Slovakia",
                   "United States") ~ "Western",
                              TRUE ~ country))
# check region
brkfst %>% 
  group_by(region) %>% 
  summarize(n = n())

## # A tibble: 4 × 2
##   region                  n
##   <chr>               <int>
## 1 East Asia              31
## 2 Indian subcontinent     6
## 3 South-East Asia        21
## 4 Western                 3

We further roll-up some variables, with low number of observations in some levels that are similar to others.

# roll up working starting time
brkfst %>% 
  group_by(work_start) %>% 
  summarize(n = n())

## # A tibble: 5 × 2
##   work_start       n
##   <chr>        <int>
## 1 07:00~08:00      2
## 2 08:00~09:00     17
## 3 09:00~10:00     30
## 4 After 10:00     10
## 5 Before 07:00     2

brkfst <- brkfst %>% 
  mutate(work_start_cut = 
           case_when(
             work_start %in% c("Before 07:00", "07:00~08:00", "08:00~09:00") ~ "Before 9:00",
             work_start %in% c("09:00~10:00", "After 10:00") ~ "After 9:00"
         ))


brkfst %>% 
  group_by(work_start_cut) %>% 
  summarize(n = n())

## # A tibble: 2 × 2
##   work_start_cut     n
##   <chr>          <int>
## 1 After 9:00        40
## 2 Before 9:00       21

# roll up exercise per week
brkfst <- brkfst %>% 
  mutate(exercise_per_week_cut = 
           case_when(
             exercise_per_week %in% c("< 1") ~ "Never",
             exercise_per_week %in% c("1-3", "4-5") ~ "1-5 times"
           ))

brkfst %>% 
  group_by(exercise_per_week_cut) %>% 
  summarize(n = n())

## # A tibble: 2 × 2
##   exercise_per_week_cut     n
##   <chr>                 <int>
## 1 1-5 times                42
## 2 Never                    19

Generating partworth utilities

Next step is to generate part worth utilies, based on responents preference for the product combinations.

# ratings cut
brkfst_rating <- 
  brkfst %>% 
  select(starts_with("PROD"))

# generating partworths
brkfst_part <- ca.part.util(brkfst_rating ,brkfst_design, attribute)

Before visualizing, we need to combine the partworth estimations with the initial data:

## Combine parthworth-demographics -----
### combine parth worth utilities with main data frame
brkfst_cmb <- 
  cbind(brkfst, brkfst_part) %>% 
  ### deal with duplicated 'none' column
  rename(L_10_None = 39,
         L_13_None = 42,
         L_16_None = 45,
  )

### rename with long ordered columns
brkfst_cmb <- 
  brkfst_cmb %>% 
  rename(L_1_200 = 30 ,
         L_2_400 = 31,
         L_3_600 = 32, 
         `L_4_Bread and Pastries` = 33,
         L_5_Onigiri = 34,
         `L_6_Protein sticks` = 35,
         `L_7_On Route to work` = 36,
         `L_8_Within 150m` = 37,
         `L_9_More than 150m` = 38,
         L_10_None = 39,
         `L_11_Attack on Titan` = 40 ,
         `L_12_Doan Ritsu` = 41,
         `L_13_None`= 42,
         `L_14_Caffeine or Alertness boost` = 43,
         `L_15_Natural Mood Stabilizer` = 44,
         L_16_None = 45 ,
         `L_17_Loyalty points` = 46,
         `L_18_Nutrition Advice` = 47
  )

To get the parthworth utilies for all the sample, We compute the column means and plot the result. These values are also used for trade-off analysis:

#overall average utilities
average_utility <- colMeans(brkfst_part)
average_utility_df <- data.frame(level = names(average_utility),
           avg_utility = average_utility)

average_utility_df <- 
  average_utility_df %>% 
  filter(level != "intercept")

average_utility_df <- 
  average_utility_df %>% 
  mutate(group =
           c("Price", "Price", "Price",
             "Form", "Form", "Form",
             "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
             "FunPackaging", "FunPackaging", "FunPackaging",
             "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
             "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
  mutate(level_fct = factor(level)) %>% 
  mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
  mutate(order_rnk = level, rank) %>% 
  mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
  unite("lng_level", c("space_char","rank","level"))
  
average_utility_df <- average_utility_df %>% 
  mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
  mutate(lng_level = as.factor(lng_level)) %>% 
  mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
  mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                            "FunPackaging", "CognitiveSupport", "DigitalIntegration"
                            )))

kable(average_utility_df %>% 
        select(lng_level, avg_utility, group),
      col.names = c("Level", "Utility", "Attribute"))

Level	Utility	Attribute
L_1_200	0.5127049	Price
L_2_400	0.0590656	Price
L_3_600	-0.5717541	Price
L_4_Bread and Pastries	0.1385902	Form
L_5_Onigiri	0.4702295	Form
L_6_Protein sticks	-0.6087377	Form
L_7_On Route to work	0.5010328	PurchaseLocation
L_8_Within 150m	-0.1460328	PurchaseLocation
L_9_More than 150m	-0.3550492	PurchaseLocation
L_10_None	0.3676230	FunPackaging
L_11_Attack on Titan	-0.1200820	FunPackaging
L_12_Doan Ritsu	-0.2476393	FunPackaging
L_13_None	-0.1534918	CognitiveSupport
L_14_Caffeine or Alertness boost	0.0520656	CognitiveSupport
L_15_Natural Mood Stabilizer	0.1013934	CognitiveSupport
L_16_None	-0.2792131	DigitalIntegration
L_17_Loyalty points	0.3036230	DigitalIntegration
L_18_Nutrition Advice	-0.0243770	DigitalIntegration

# kable(brkfst_desc_slice,
#       col.names = c("Observations", "Level","Utility", "Attribute"))

Visualizing the partworth utilities for all the sample is done with the following code.

ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                               ,fill = group_fct
))+
  geom_col() +
  coord_flip() + 
  scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
  geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
  ggtitle(paste("All sample", length(brkfst$nickname), sep = ", n=")) +
  guides(fill="none")

To evaluate relative ordinal preference, we can sort descending by utility:

## all sample parthworth utilities - sorted descending
plot_list <- list()
n_obs = length(brkfst_cmb$nickname)
iter = "All sample"

  brkfst_desc_slice <-  brkfst_cmb %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
# kable(brkfst_desc_slice,
#       col.names = c("Observations", "Level","Utility", "Attribute"))
    ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none") +
    theme(legend.position="bottom")

Computing importance

Overall all sample

Going further, we plot the importance overall first.

# Importance - # Overall all sample
kable(ca.importance(brkfst_part, attribute),
      col.names = "Attribute importance")

	Attribute importance
Price	0.2424731
Form	0.2412452
PurchaseLocation	0.1914105
FunPackaging	0.1375659
CognitiveSupport	0.0569895
DigitalIntegration	0.1303157

Visualizing importance for the whole sample:

## plot importance overall
sub_importance <- 
  ca.importance(brkfst_part, attribute)

sub_importance_df <- data.frame(
  sub_importance = sub_importance,
  attribute_txt = names(sub_importance)
)
sub_importance_df <- sub_importance_df %>% 
  mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                      "FunPackaging", "CognitiveSupport", "DigitalIntegration"
  )))

ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                              fill=group_fct)) +
  geom_col() +
  coord_flip() +
  scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
  geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
  ggtitle(paste("All sample", length(brkfst$nickname), sep = ", n=")) +
  guides(fill="none")

It can be observed that for the whole sample, there are two variables that are very closely tied together: Price with 24% and Form with 24%. This suggests likely a trade-off between two different needs (low price and personal taste), which can be investigated through segmentation.

Exploratory data analysis for subgroups

Gender

We turn to subgroups. First, we explore the parthworth utility by gender:

#segmenting part-worth utilities
# ===== 
# gender

plot_list <- list()
var_by = brkfst$gender
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, length(brkfst$nickname), sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by gender, we can sort descending:

# gender- sorted descending
plot_list <- list()
var_by = brkfst_cmb$gender
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none") +
    theme(legend.position="bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

Subsequently, the importance of gender becomes:

#breakdown of importance by subcomponents
#### by gender
plot_list <- list()
var_by = brkfst$gender
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Region

Turning to region, the partworth utilities:

#segmenting part-worth utilities
# ===== 
# region

plot_list <- list()
var_by = brkfst$region
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by region, we can sort descending:

# region - sorted descending
plot_list <- list()
var_by = brkfst_cmb$region
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The importance of region is as follows.

#### by region
plot_list <- list()
var_by = brkfst$region
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Age

Turning to Age, the parthworth utilities are:

#segmenting part-worth utilities
# ===== 
# age

plot_list <- list()
var_by = brkfst$age
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by age, we can sort descending:

# age - sorted descending
plot_list <- list()
var_by = brkfst_cmb$age
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The importance of Age is as follows.

# importance
#### by age
plot_list <- list()
var_by = brkfst$age
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n =")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Civil status

Exploring by whether a person is leaving with their partner or not. The partworth utilities of Civil Status are:

#segmenting part-worth utilities
# ===== 
# living with partner

plot_list <- list()
var_by = brkfst$living_with_partner
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by civil status, we can sort descending:

# civil status - sorted descending
plot_list <- list()
var_by = brkfst_cmb$living_with_partner
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The importance of Civil Status is:

# importance
#### by living with partner
plot_list <- list()
var_by = brkfst$living_with_partner
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n =")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Expected Salary

Reflecting career ladder status and aspirations. The partworth utilities are:

#segmenting part-worth utilities
# ===== 
# living with partner

plot_list <- list()
var_by = brkfst$expected_salary
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by expected salary, we can sort descending:

# expected salary - sorted descending
plot_list <- list()
var_by = brkfst_cmb$expected_salary
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The importance thus is:

#### by expected salary
plot_list <- list()
var_by = brkfst$expected_salary
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n =")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Dietary restrictions

Exploring the impact of personal dietary restrictions. Partworth utilities are:

#segmenting part-worth utilities
# ===== 
# dietary restriction

plot_list <- list()
var_by = brkfst$dietary_restrictions
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by dietary restrictions, we can sort descending:

# dietary restrictions - sorted descending
plot_list <- list()
var_by = brkfst_cmb$dietary_restrictions
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The importance is:

## importance
#### by dietary restriction
plot_list <- list()
var_by = brkfst$dietary_restrictions
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n =")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Work start

Breaking down by the time that the work day starts. The parthworth utilities:

#segmenting part-worth utilities
# ===== 
# work_start cut

plot_list <- list()
var_by = brkfst$work_start_cut
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by work start time, we can sort descending:

# work start cut - sorted descending
plot_list <- list()
var_by = brkfst_cmb$work_start_cut
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The work start importance:

#### by work start
plot_list <- list()
var_by = brkfst$work_start_cut
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n =")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Exercise frequency

The number of times a person exercises per week. Partworth utilities:

#segmenting part-worth utilities
# ===== 
# exercise per week cut

plot_list <- list()
var_by = brkfst$exercise_per_week_cut
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by exercise frequency, we can sort descending:

# exercise frequency - sorted descending
plot_list <- list()
var_by = brkfst_cmb$exercise_per_week_cut
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The importance is:

#### by exercise per week
plot_list <- list()
var_by = brkfst$exercise_per_week_cut
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n =")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Alcohol consumption

How much a person’s love for drinking influences their breakfast preferences. The parthworth utilities:

#segmenting part-worth utilities
# ===== 
# alcohol per week
plot_list <- list()
var_by = brkfst$alcohol_per_week
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  average_utility <- colMeans(brkfst_part[var_by==iter,,drop=FALSE])
  average_utility_df <- data.frame(level = names(average_utility),
                                   avg_utility = average_utility)
  
  average_utility_df <- 
    average_utility_df %>% 
    filter(level != "intercept")
  
  average_utility_df <- 
    average_utility_df %>% 
    mutate(group =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>% 
    mutate(level_fct = factor(level)) %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(order_rnk = level, rank) %>% 
    mutate(space_char = rep(c("L"), length(average_utility_df$level))) %>% 
    unite("lng_level", c("space_char","rank","level"))
  
  average_utility_df <- average_utility_df %>% 
    mutate(rank = seq.int(1:length(average_utility_df$level))) %>% 
    mutate(lng_level = as.factor(lng_level)) %>% 
    mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
    mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                                "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  
  plot_list[[i]] <- ggplot(average_utility_df, aes(x=lng_level, y = avg_utility
                                                   ,fill = group_fct
  ))+
    geom_col() +
    coord_flip() + 
    scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(avg_utility, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    guides(fill="none")
}
grid.arrange(grobs=plot_list,ncol=2)

To visualize relative importance by alcohol consumption, we can sort descending:

# alcohol consumption - sorted descending
plot_list <- list()
var_by = brkfst_cmb$alcohol_per_week
attr_levels <- unique(var_by)


for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_cmb[var_by == iter,1])
  
  brkfst_desc_slice <-  brkfst_cmb[var_by == iter,] %>% 
    mutate(item_col = iter) %>% 
    group_by(item_col) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-item_col) %>% 
    mutate(group_aggr =
             c("Price", "Price", "Price",
               "Form", "Form", "Form",
               "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
               "FunPackaging", "FunPackaging", "FunPackaging",
               "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
               "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
             )) %>%
    mutate(group_aggr = 
             factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                           "FunPackaging", "CognitiveSupport", "DigitalIntegration"
             ))) %>% 
    arrange(desc(value)) %>% 
    ungroup
  
  #kable(brkfst_desc_slice)
  
  
  plot_list[[i]] <- ggplot(brkfst_desc_slice, 
                           aes(x= reorder(name,value), y = value
                               ,fill = group_aggr
                           ))+
    geom_col() +
    coord_flip() + 
    #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
    geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n=")) +
    #guides(fill="none")
    theme(legend.position = "bottom")
}
grid.arrange(grobs=plot_list,ncol=2)

The importance of alcohol consumption:

#### by alcohol per week
plot_list <- list()
var_by = brkfst$alcohol_per_week
attr_levels <- unique(var_by)

for (i in seq_along(attr_levels)) {
  
  iter = attr_levels[i]
  n_obs = length(brkfst_part[var_by == iter,1])
  
  sub_importance <- 
    ca.importance(brkfst_part[var_by == iter,], attribute)
  
  sub_importance_df <- data.frame(
    sub_importance = sub_importance,
    attribute_txt = names(sub_importance)
  )
  sub_importance_df <- sub_importance_df %>% 
    mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                        "FunPackaging", "CognitiveSupport", "DigitalIntegration"
    )))
  
  plot_list[[i]] <- ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                                                  fill=group_fct)) +
    geom_col() +
    coord_flip() +
    scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
    geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
    ggtitle(paste(iter, n_obs, sep = ", n =")) +
    guides(fill="none")
}

grid.arrange(grobs=plot_list,ncol=2)

Segmentation

Estimation and Interpretation

To gain insight into behavioral subgroups, we run a segmentation analysis. To decide the number of clusters, we first look at the silhouette plot.

# exclude intercept column
brkfst_part_sg <- data.frame(brkfst_part[,-1])
names(brkfst_part_sg)[10] <- c("No special packaging")
names(brkfst_part_sg)[13] <- c("No cognitive support")
names(brkfst_part_sg)[16] <- c("No digital integration")

# silhouette plot
fviz_nbclust(brkfst_part_sg, kmeans, method="silhouette")

Estimating four clusters:

# estimating clusters
brkfst_sg_4 <- k.means(brkfst_part_sg, n.cluster=4)

# Cluster sizes
prop.table(brkfst_sg_4$size)

## [1] 0.36065574 0.27868852 0.26229508 0.09836066

# interpreting clusters
snake.ch2(brkfst_sg_4)

#Cluster plot
fviz_cluster(brkfst_sg_4, brkfst_part_sg, ellipse.type = "convex",
             ggtheme = theme_minimal())

Estimating seven clusters:

# estimating clusters
brkfst_sg_7 <- k.means(brkfst_part_sg, n.cluster=7)

# Cluster sizes
prop.table(brkfst_sg_7$size)

## [1] 0.13114754 0.09836066 0.26229508 0.09836066 0.14754098 0.08196721 0.18032787

# interpreting clusters
snake.ch2(brkfst_sg_7)

#Cluster plot
fviz_cluster(brkfst_sg_7, brkfst_part_sg, ellipse.type = "convex",
             ggtheme = theme_minimal())

Segment composition

To visualize composition of each cluster - we create a table of each cluster.

To view individual names, we have to replace the variable "country2" with "nickname" in the code below.

## segment composition -----
# For analysis: Keep as separate vectors
brkfst_clst <- cbind(brkfst_cmb, 
                     cluster = brkfst_sg_4$cluster)

cluster1_names <- brkfst_clst[brkfst_clst$cluster == 1, "country2"]
cluster2_names <- brkfst_clst[brkfst_clst$cluster == 2, "country2"]
cluster3_names <- brkfst_clst[brkfst_clst$cluster == 3, "country2"]
cluster4_names <- brkfst_clst[brkfst_clst$cluster == 4, "country2"]


# For presentation: Create NA-padded data frame
presentation_df <- data.frame(
  cluster1 = c(cluster1_names, rep(NA, length(cluster1_names) - length(cluster1_names))),
  cluster2 = c(cluster2_names, rep(NA, length(cluster1_names) - length(cluster2_names))),
  cluster3 = c(cluster3_names, rep(NA, length(cluster1_names) - length(cluster3_names))),
  cluster4 = c(cluster4_names, rep(NA, length(cluster1_names) - length(cluster4_names)))
)

kable(presentation_df)

cluster1	cluster2	cluster3	cluster4
Taiwan	Singapore	Japan	Singapore
Romania	China	China	India
Bangladesh	Taiwan	China	China
India	India	China	Japan
Myanmar	Singapore	Taiwan	Thailand
Taiwan	Singapore	Singapore	Thailand
Japan	Singapore	Singapore	NA
Vietnam	Bulgaria	India	NA
Malaysia	Bangladesh	China	NA
Philippines	Malaysia	China	NA
Japan	Japan	China	NA
Japan	Japan	Philippines	NA
Taiwan	China	Thailand	NA
Romania	Vietnam	Vietnam	NA
Singapore	Japan	China	NA
Japan	Taiwan	China	NA
Mongolia	Vietnam	NA	NA
Taiwan	NA	NA	NA
Korea	NA	NA	NA
Philippines	NA	NA	NA
South Korea	NA	NA	NA
Japan	NA	NA	NA

Trade-off calculation

We first prepare the object for trade-off:

### allocate separate object for all trade-off calculation
average_utility <- colMeans(brkfst_part)
average_utility_df_all <- data.frame(level = names(average_utility),
                                     avg_utility = average_utility)

average_utility_df_all <- 
  average_utility_df_all %>% 
  filter(level != "intercept")

average_utility_df_all  <- 
  average_utility_df_all  %>% 
  mutate(group =
           c("Price", "Price", "Price",
             "Form", "Form", "Form",
             "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
             "FunPackaging", "FunPackaging", "FunPackaging",
             "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
             "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
           )) %>% 
  mutate(level_fct = factor(level)) %>% 
  mutate(rank = seq.int(1:length(average_utility_df_all$level))) %>% 
  mutate(order_rnk = level, rank) %>% 
  mutate(space_char = rep(c("L"), length(average_utility_df_all$level))) %>% 
  unite("lng_level", c("space_char","rank","level"))

average_utility_df_all <- average_utility_df_all %>% 
  mutate(rank = seq.int(1:length(average_utility_df_all$level))) %>% 
  mutate(lng_level = as.factor(lng_level)) %>% 
  mutate(lng_level = fct_reorder(lng_level, rank )) %>% 
  mutate(group_fct = factor(group, levels = c("Price", "Form", "PurchaseLocation",
                                              "FunPackaging", "CognitiveSupport", "DigitalIntegration"
  )))

Subsequently, we can calculate the average value of one monetary utility:

\(\frac{¥600 - ¥200}{0.513-(-0.572)}\) = ¥368.85

# average monetary value of 1 utiliy
# linear utility function
util_linear_value <-  (600-200)/
  (average_utility_df_all[average_utility_df_all$lng_level ==
                            "L_1_200",]$avg_utility-
     average_utility_df_all[average_utility_df_all$lng_level ==
                              "L_3_600",]$avg_utility)
util_linear_value

## [1] 368.8475

# piece-wise utility function
util_piecewise_1 <- (600-400)/(average_utility["400"]-average_utility["600"])
util_piecewise_1

##      400 
## 317.0478

util_piecewise_2 <- (400-200)/(average_utility["200"]-average_utility["400"])
util_piecewise_2  

##      200 
## 440.8789

To visualize the trade-off, we can plot:

tri_df_points <- 
  data.frame(
    price = c(200, 600),
    utility = 
      c(average_utility_df_all[average_utility_df_all$lng_level ==
                                 "L_1_200",]$avg_utility,
        average_utility_df_all[average_utility_df_all$lng_level ==
                                 "L_3_600",]$avg_utility)
  )

ggplot(tri_df_points, 
       aes(x = price, y = utility)) +
  geom_point() + geom_line()

Going from no cognitive support to Caffeine and Alertness boost, the client would be willing to pay more:

# moving from none to caffeine or alertness boost
delta_cognitive_support_none_caffeine <- (average_utility_df_all[average_utility_df_all$lng_level=="L_14_Caffeine or Alertness boost",]$avg_utility -
                                            average_utility_df_all[average_utility_df_all$lng_level=="L_13_None",]$avg_utility) * util_linear_value
delta_cognitive_support_none_caffeine

## [1] 75.81933

Going from no cognitive support to Natural Mood stabilizer, the client would be willing to pay more:

# moving from none to natural mood stabilizers
delta_cognitive_support_none_naturalmood <- 
  (average_utility_df_all[average_utility_df_all$lng_level=="L_15_Natural Mood Stabilizer",]$avg_utility -
     average_utility_df_all[average_utility_df_all$lng_level=="L_13_None",]$avg_utility) * util_linear_value
delta_cognitive_support_none_naturalmood

## [1] 94.01379

Market share prediction

Commercial considerations

Before deciding on a product launch, it may be useful to review the preferences of the Japanese consumer.

The parthworth for the Japanese consumer:

## tastes of the Japanese consumer
## partworth - sorted descending For Japan
iter = "Japan"
n_obs = length(brkfst_cmb[brkfst_cmb$country2 == iter,1])

brkfst_desc_slice <-  brkfst_cmb[brkfst_cmb$country2 == iter,] %>% 
  mutate(item_col = iter) %>% 
  group_by(item_col) %>% 
  summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
               mean , na.rm = TRUE) %>% 
  pivot_longer(-item_col) %>% 
  mutate(group_aggr =
           c("Price", "Price", "Price",
             "Form", "Form", "Form",
             "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
             "FunPackaging", "FunPackaging", "FunPackaging",
             "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
             "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
           )) %>%
  mutate(group_aggr = 
           factor(group_aggr, levels = c("Price", "Form", "PurchaseLocation",
                                         "FunPackaging", "CognitiveSupport", "DigitalIntegration"
           ))) %>% 
  arrange(desc(value)) %>% 
  ungroup

ggplot(brkfst_desc_slice, 
       aes(x= reorder(name,value), y = value
           ,fill = group_aggr
       ))+
  geom_col() +
  coord_flip() + 
  #scale_x_discrete(limits = rev(levels(average_utility_df$lng_level))) +
  geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) +
  ggtitle(paste(iter, n_obs, sep = ", n=")) +
  guides(fill="none")

And the importance:

## importance of attributes for the Japanese consumer
#### Japan - importance
iter = "Japan"
var_by = brkfst$country2

n_obs = length(brkfst_part[var_by == iter,1])

sub_importance <- 
  ca.importance(brkfst_part[var_by == iter,], attribute)

sub_importance_df <- data.frame(
  sub_importance = sub_importance,
  attribute_txt = names(sub_importance)
)
sub_importance_df <- sub_importance_df %>% 
  mutate(group_fct = factor(attribute_txt, levels = c("Price", "Form", "PurchaseLocation",
                                                      "FunPackaging", "CognitiveSupport", "DigitalIntegration"
  )))

ggplot(sub_importance_df, aes(x=group_fct, y = sub_importance,
                              fill=group_fct)) +
  geom_col() +
  coord_flip() +
  scale_x_discrete(limits = rev(levels(sub_importance_df$group_fct))) +
  geom_text(aes(label = format(round(sub_importance, 2), nsmall = 2)), vjust = -0.5) +
  ggtitle(paste(iter, n_obs, sep = ", n=")) +
  guides(fill="none")

Estimation of market share (Logit)

In order to test our potential market share, we benchmark against four existing alternatives:

• the pastrami croissant from Paul Shimbashi
• the 7-Eleven onigiri
• the melonpan at Shimbashi cafe
• the Family Mart protein stick

# Market Prediction
## 5 benchmarks
## Paul shimbashi, pastrami croissant
brkfst_sim <- data.frame(
  Price = c("600"),
  Form = c("Bread and Pastries"),
  PurchaseLocation = c("On Route to work"),
  FunPackaging = c("None"),
  CognitiveSupport = c("None"),
  DigitalIntegration = c("None")
)

# 7-eleven onigiri
brkfst_sim <- rbind(brkfst_sim,
                    c("200","Onigiri","On Route to work","None","None","None"))


# Shimbashi cafe melonpan
brkfst_sim <- rbind(brkfst_sim,
                    c("600","Bread and Pastries","On Route to work","Attack on Titan","None","None"))



# Family Mart protein stick okaki
brkfst_sim <- rbind(brkfst_sim,
                    c("400","Protein sticks","Within 150m","None","None","None"))


# Our own product
brkfst_sim <- rbind(brkfst_sim,
                    c("400","Onigiri","Within 150m","Attack on Titan",
                      "Natural Mood Stabilizer","Loyalty points"))

Computing our market share:

market_share <- 
  data.frame(product = c("Paul pastrami croissant",
                         "7-eleven onigiri",
                         "Shimbashi cafe",
                         "Family Mart protein stick",
                         "MCU new excellent product"),
             mkt_share = ca.logit(brkfst_sim, brkfst_part, brkfst_design))

ggplot(market_share, aes(x= product, y = mkt_share,
                         fill=product)) +
  geom_col() +
  coord_flip() +
  scale_x_discrete(limits=rev) +
  geom_text(aes(label = format(round(mkt_share, 2), nsmall = 2)), vjust = -0.5)

It seems it is not easy to beat the trusted onigiri in Japan.

Appendix - Various data tables

Code for various tables.

Partworth by variable

To compute the parthworth by a specific variable, we can run:

## code for tables -----
### for variables
var_by <-  "exercise_per_week_cut"

kable(
  brkfst_cmb %>% 
    group_by(group_var = eval(as.name(paste(var_by)))) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-group_var) %>% 
    pivot_wider(id_cols = name, names_from = "group_var",
                values_from = "value")
)

name	1-5 times	Never
L_1_200	0.5648571	0.3974211
L_2_400	0.0333333	0.1159474
L_3_600	-0.5981667	-0.5133684
L_4_Bread and Pastries	0.0090714	0.4248947
L_5_Onigiri	0.5631905	0.2647368
L_6_Protein sticks	-0.5722143	-0.6894737
L_7_On Route to work	0.4747857	0.5590526
L_8_Within 150m	-0.1070000	-0.2323158
L_9_More than 150m	-0.3677143	-0.3270526
L_10_None	0.3326190	0.4450000
L_11_Attack on Titan	-0.1328571	-0.0918421
L_12_Doan Ritsu	-0.1998571	-0.3532632
L_13_None	-0.1348810	-0.1946316
L_14_Caffeine or Alertness boost	0.0235476	0.1151053
L_15_Natural Mood Stabilizer	0.1113333	0.0794211
L_16_None	-0.2365000	-0.3736316
L_17_Loyalty points	0.3478571	0.2058421
L_18_Nutrition Advice	-0.1113095	0.1677895

Partworth by observations

To investigate specific observations or subgroups we use the filter() function, passing the variable and specific observations, as below:

### for specific observations
kable(
  brkfst_cmb %>% 
    filter(nickname %in% c("Marius", "Abigail", "Yun", "Matt", "Pup")) %>% 
    group_by(nickname) %>% 
    summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
                 mean , na.rm = TRUE) %>% 
    pivot_longer(-nickname) %>% 
    pivot_wider(id_cols = name, names_from = "nickname",
                values_from = "value")
)

name	Abigail	Marius	Matt	Pup	Yun
L_1_200	1.899	1.043	0.710	1.319	0.609
L_2_400	0.094	-0.326	0.341	-0.225	-0.065
L_3_600	-1.993	-0.717	-1.051	-1.094	-0.543
L_4_Bread and Pastries	-0.728	-0.402	-0.902	0.634	-0.547
L_5_Onigiri	0.609	0.739	0.739	-1.246	1.681
L_6_Protein sticks	0.120	-0.337	0.163	0.612	-1.134
L_7_On Route to work	0.337	1.141	0.308	0.786	-0.105
L_8_Within 150m	0.057	-0.396	-0.729	-0.268	-0.172
L_9_More than 150m	-0.393	-0.746	0.421	-0.518	0.278
L_10_None	0.523	0.338	0.004	0.399	0.028
L_11_Attack on Titan	0.473	1.188	-0.646	-0.851	0.078
L_12_Doan Ritsu	-0.996	-1.525	0.641	0.453	-0.105
L_13_None	-0.486	-0.430	0.404	-0.446	0.167
L_14_Caffeine or Alertness boost	0.040	-0.112	-0.279	0.315	-0.489
L_15_Natural Mood Stabilizer	0.446	0.542	-0.125	0.130	0.322
L_16_None	-0.420	-1.563	-0.396	-0.446	-0.233
L_17_Loyalty points	0.713	1.009	-0.325	0.130	-0.278
L_18_Nutrition Advice	-0.293	0.554	0.721	0.315	0.511

Comparing two countries

To compare two specific countries, for example China and Japan, we can run:

## country comparison
brkfst_cmb %>% 
  filter(country2 %in% c("Japan", "China")) %>% 
  group_by(country2) %>% 
  summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
               mean , na.rm = TRUE) %>% 
  pivot_longer(-country2) %>% 
  pivot_wider(id_cols = name, names_from = "country2",
              values_from = "value") 

## # A tibble: 18 × 3
##    name                               China   Japan
##    <chr>                              <dbl>   <dbl>
##  1 L_1_200                           0.590   0.590 
##  2 L_2_400                           0.134  -0.0405
##  3 L_3_600                          -0.724  -0.549 
##  4 L_4_Bread and Pastries           -0.164   0.252 
##  5 L_5_Onigiri                      -0.147   0.761 
##  6 L_6_Protein sticks                0.312  -1.01  
##  7 L_7_On Route to work              0.593   0.375 
##  8 L_8_Within 150m                   0.0195 -0.278 
##  9 L_9_More than 150m               -0.612  -0.0977
## 10 L_10_None                         0.0924  0.636 
## 11 L_11_Attack on Titan             -0.0485 -0.544 
## 12 L_12_Doan Ritsu                  -0.0437 -0.0915
## 13 L_13_None                        -0.0725 -0.0403
## 14 L_14_Caffeine or Alertness boost -0.088  -0.138 
## 15 L_15_Natural Mood Stabilizer      0.160   0.178 
## 16 L_16_None                        -0.0361 -0.434 
## 17 L_17_Loyalty points               0.124   0.505 
## 18 L_18_Nutrition Advice            -0.0879 -0.071

brkfst_cmb_plot <- brkfst_cmb %>% 
  filter(country2 %in% c("Japan", "China")) %>% 
  group_by(country2) %>% 
  summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
               mean , na.rm = TRUE) %>% 
  pivot_longer(-country2) %>% 
  # mutate(country2 = factor(country2,
  #                          levels = c("Japan", "China"))) %>% 
  mutate(name = factor(name,
                       levels = c("L_1_200", 
                                  "L_2_400",
                                  "L_3_600",
                                  "L_4_Bread and Pastries",
                                  "L_5_Onigiri",
                                  "L_6_Protein sticks",
                                  "L_7_On Route to work",
                                  "L_8_Within 150m",
                                  "L_9_More than 150m",
                                  "L_10_None",
                                  "L_11_Attack on Titan",
                                  "L_12_Doan Ritsu",
                                  "L_13_None",
                                  "L_14_Caffeine or Alertness boost",
                                  "L_15_Natural Mood Stabilizer",
                                  "L_16_None",
                                  "L_17_Loyalty points",
                                  "L_18_Nutrition Advice")))

ggplot(brkfst_cmb_plot, aes(x=name , y = value,
                            group = country2, fill=country2)) +
  geom_col(position = "dodge") +
  coord_flip() +
  scale_x_discrete(limits = rev(levels(brkfst_cmb_plot$name))) +
  geom_text(aes(label = format(round(value, 2), nsmall = 2)), vjust = -0.5) 

#ggtitle(paste(iter, n_obs, sep = ", n =")) +
#guides(fill="none")

The Japanese Consumer

To see the parthworth only for the Japanese subgroup, we run:

brkfst_cmb %>% 
  filter(country2 %in% c("Japan")) %>% 
  group_by(country2) %>% 
  summarise_at(vars(L_1_200:`L_18_Nutrition Advice`),
               mean , na.rm = TRUE) %>% 
  pivot_longer(-country2) %>% 
  # mutate(country2 = factor(country2,
  #                          levels = c("Japan", "China"))) %>% 
  mutate(name = factor(name,
                       levels = c("L_1_200", 
                                  "L_2_400",
                                  "L_3_600",
                                  "L_4_Bread and Pastries",
                                  "L_5_Onigiri",
                                  "L_6_Protein sticks",
                                  "L_7_On Route to work",
                                  "L_8_Within 150m",
                                  "L_9_More than 150m",
                                  "L_10_None",
                                  "L_11_Attack on Titan",
                                  "L_12_Doan Ritsu",
                                  "L_13_None",
                                  "L_14_Caffeine or Alertness boost",
                                  "L_15_Natural Mood Stabilizer",
                                  "L_16_None",
                                  "L_17_Loyalty points",
                                  "L_18_Nutrition Advice"))) %>% 
  mutate(group_aggr =
           c("Price", "Price", "Price",
             "Form", "Form", "Form",
             "PurchaseLocation", "PurchaseLocation", "PurchaseLocation",
             "FunPackaging", "FunPackaging", "FunPackaging",
             "CognitiveSupport", "CognitiveSupport","CognitiveSupport",
             "DigitalIntegration", "DigitalIntegration", "DigitalIntegration"
           )) %>% 
  arrange(desc(value))

## # A tibble: 18 × 4
##    country2 name                               value group_aggr        
##    <chr>    <fct>                              <dbl> <chr>             
##  1 Japan    L_5_Onigiri                       0.761  Form              
##  2 Japan    L_10_None                         0.636  FunPackaging      
##  3 Japan    L_1_200                           0.590  Price             
##  4 Japan    L_17_Loyalty points               0.505  DigitalIntegration
##  5 Japan    L_7_On Route to work              0.375  PurchaseLocation  
##  6 Japan    L_4_Bread and Pastries            0.252  Form              
##  7 Japan    L_15_Natural Mood Stabilizer      0.178  CognitiveSupport  
##  8 Japan    L_13_None                        -0.0403 CognitiveSupport  
##  9 Japan    L_2_400                          -0.0405 Price             
## 10 Japan    L_18_Nutrition Advice            -0.071  DigitalIntegration
## 11 Japan    L_12_Doan Ritsu                  -0.0915 FunPackaging      
## 12 Japan    L_9_More than 150m               -0.0977 PurchaseLocation  
## 13 Japan    L_14_Caffeine or Alertness boost -0.138  CognitiveSupport  
## 14 Japan    L_8_Within 150m                  -0.278  PurchaseLocation  
## 15 Japan    L_16_None                        -0.434  DigitalIntegration
## 16 Japan    L_11_Attack on Titan             -0.544  FunPackaging      
## 17 Japan    L_3_600                          -0.549  Price             
## 18 Japan    L_6_Protein sticks               -1.01   Form

Trivia (dangerous)